home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / defmacro.lisp < prev    next >
Encoding:
Text File  |  1992-12-09  |  14.4 KB  |  418 lines
  1. ;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: defmacro.lisp,v 1.13 92/08/12 18:56:32 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Written by Blaine Burks.
  15. ;;;
  16. (in-package "LISP")
  17.  
  18.  
  19. ;;;; Some variable definitions.
  20.  
  21. ;;; Variables for amassing the results of parsing a defmacro.  Declarations
  22. ;;; in DEFMACRO are the reason this isn't as easy as it sounds.
  23. ;;;
  24. (defvar *arg-tests* ()
  25.   "A list of tests that do argument counting at expansion time.")
  26.  
  27. (defvar *system-lets* ()
  28.   "Let bindings that are done to make lambda-list parsing possible.")
  29.  
  30. (defvar *user-lets* ()
  31.   "Let bindings that the user has explicitly supplied.")
  32.  
  33. (defvar *default-default* nil
  34.   "Unsupplied optional and keyword arguments get this value defaultly.")
  35.  
  36.  
  37. ;;;; Stuff to parse DEFMACRO, MACROLET, DEFINE-SETF-METHOD, and DEFTYPE.
  38.  
  39. ;;; PARSE-DEFMACRO returns, as multiple-values, a body, possibly a declare
  40. ;;; form to put where this code is inserted, and the documentation for the
  41. ;;; parsed body.
  42. ;;;
  43. (defun parse-defmacro (lambda-list arg-list-name code name error-kind
  44.                    &key (annonymousp nil)
  45.                    (doc-string-allowed t)
  46.                    ((:environment env-arg-name))
  47.                    ((:default-default *default-default*))
  48.                    (error-fun 'error))
  49.   "Returns as multiple-values a parsed body, any local-declarations that
  50.    should be made where this body is inserted, and a doc-string if there is
  51.    one."
  52.   (multiple-value-bind (body declarations documentation)
  53.                (parse-body code nil doc-string-allowed)
  54.     (let* ((*arg-tests* ())
  55.        (*user-lets* ())
  56.        (*system-lets* ()))
  57.       (multiple-value-bind
  58.       (env-arg-used minimum maximum)
  59.       (parse-defmacro-lambda-list lambda-list arg-list-name name
  60.                       error-kind error-fun (not annonymousp)
  61.                       nil env-arg-name)
  62.     (values
  63.      `(let* ,(nreverse *system-lets*)
  64.         ,@*arg-tests*
  65.         (let* ,(nreverse *user-lets*)
  66.           ,@declarations
  67.           ,@body))
  68.      (if (and env-arg-name (not env-arg-used))
  69.          `((declare (ignore ,env-arg-name)))
  70.          nil)
  71.      documentation
  72.      minimum
  73.      maximum)))))
  74.  
  75.  
  76. (defun parse-defmacro-lambda-list
  77.        (lambda-list arg-list-name name error-kind error-fun
  78.             &optional top-level env-illegal env-arg-name)
  79.   (let ((path (if top-level `(cdr ,arg-list-name) arg-list-name))
  80.     (now-processing :required)
  81.     (maximum 0)
  82.     (minimum 0)
  83.     (keys ())
  84.     rest-name restp allow-other-keys-p env-arg-used)
  85.     ;; This really strange way to test for '&whole is neccessary because member
  86.     ;; does not have to work on dotted lists, and dotted lists are legal
  87.     ;; in lambda-lists.
  88.     (when (and (do ((list lambda-list (cdr list)))
  89.            ((atom list) nil)
  90.          (when (eq (car list) '&whole) (return t)))
  91.            (not (eq (car lambda-list) '&whole)))
  92.       (error "&Whole must appear first in ~S lambda-list." error-kind))
  93.     (do ((rest-of-args lambda-list (cdr rest-of-args)))
  94.     ((atom rest-of-args)
  95.      (cond ((null rest-of-args) nil)
  96.            ;; Varlist is dotted, treat as &rest arg and exit.
  97.            (t (push-let-binding rest-of-args path nil)
  98.           (setf restp t))))
  99.       (let ((var (car rest-of-args)))
  100.     (cond ((eq var '&whole)
  101.            (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
  102.               (setf rest-of-args (cdr rest-of-args))
  103.               (push-let-binding (car rest-of-args) arg-list-name nil))
  104.              (t
  105.               (defmacro-error "&WHOLE" error-kind name))))
  106.           ((eq var '&environment)
  107.            (cond (env-illegal
  108.               (error "&Environment not valid with ~S." error-kind))
  109.              ((not top-level)
  110.               (error "&Environment only valid at top level of ~
  111.               lambda-list.")))
  112.            (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
  113.               (setf rest-of-args (cdr rest-of-args))
  114.               (push-let-binding (car rest-of-args) env-arg-name nil)
  115.               (setf env-arg-used t))
  116.              (t
  117.               (defmacro-error "&ENVIRONMENT" error-kind name))))
  118.           ((or (eq var '&rest) (eq var '&body))
  119.            (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args)))
  120.               (setf rest-of-args (cdr rest-of-args))
  121.               (setf restp t)
  122.               (push-let-binding (car rest-of-args) path nil))
  123.              ;;
  124.              ;; This branch implements an incompatible extension to
  125.              ;; Common Lisp.  In place of a symbol following &body,
  126.              ;; there may be a list of up to three elements which will
  127.              ;; be bound to the body, declarations, and doc-string of
  128.              ;; the body.
  129.              ((and (cdr rest-of-args)
  130.                (consp (cadr rest-of-args))
  131.                (symbolp (caadr rest-of-args)))
  132.               (setf rest-of-args (cdr rest-of-args))
  133.               (setf restp t)
  134.               (let ((body-name (caar rest-of-args))
  135.                 (declarations-name (cadar rest-of-args))
  136.                 (doc-string-name (caddar rest-of-args))
  137.                 (parse-body-values (gensym)))
  138.             (push-let-binding
  139.              parse-body-values
  140.              `(multiple-value-list
  141.                (parse-body ,path ,env-arg-name
  142.                        ,(not (null doc-string-name))))
  143.              t)
  144.             (setf env-arg-used t)
  145.             (when body-name
  146.               (push-let-binding body-name
  147.                         `(car ,parse-body-values) nil))
  148.             (when declarations-name
  149.               (push-let-binding declarations-name
  150.                         `(cadr ,parse-body-values) nil))
  151.             (when doc-string-name
  152.               (push-let-binding doc-string-name
  153.                         `(caddr ,parse-body-values) nil))))
  154.              (t
  155.               (defmacro-error (symbol-name var) error-kind name))))
  156.           ((eq var '&optional)
  157.            (setf now-processing :optionals))
  158.           ((eq var '&key)
  159.            (setf now-processing :keywords)
  160.            (setf rest-name (gensym "KEYWORDS-"))
  161.            (setf restp t)
  162.            (push-let-binding rest-name path t))
  163.           ((eq var '&allow-other-keys)
  164.            (setf allow-other-keys-p t))
  165.           ((eq var '&aux)
  166.            (setf now-processing :auxs))
  167.           ((listp var)
  168.            (case now-processing
  169.          (:required
  170.           (let ((sub-list-name (gensym "SUBLIST-")))
  171.             (push-sub-list-binding sub-list-name `(car ,path) var
  172.                        name error-kind error-fun)
  173.             (parse-defmacro-lambda-list var sub-list-name name
  174.                         error-kind error-fun))
  175.           (setf path `(cdr ,path))
  176.           (incf minimum)
  177.           (incf maximum))
  178.          (:optionals
  179.           (when (> (length var) 3)
  180.             (cerror "Ignore extra noise."
  181.                 "More than variable, initform, and suppliedp ~
  182.                 in &optional binding - ~S"
  183.                 var))
  184.           (push-optional-binding (car var) (cadr var) (caddr var)
  185.                      `(not (null ,path)) `(car ,path)
  186.                      name error-kind error-fun)
  187.           (setf path `(cdr ,path))
  188.           (incf maximum))
  189.          (:keywords
  190.           (let* ((keyword-given (consp (car var)))
  191.              (variable (if keyword-given
  192.                        (cadar var)
  193.                        (car var)))
  194.              (keyword (if keyword-given
  195.                       (caar var)
  196.                       (make-keyword variable)))
  197.              (supplied-p (caddr var)))
  198.             (push-optional-binding variable (cadr var) supplied-p
  199.                        `(keyword-supplied-p ',keyword
  200.                                 ,rest-name)
  201.                        `(lookup-keyword ',keyword
  202.                                 ,rest-name)
  203.                        name error-kind error-fun)
  204.             (push keyword keys)))
  205.          (:auxs (push-let-binding (car var) (cadr var) nil))))
  206.           ((symbolp var)
  207.            (case now-processing
  208.          (:required
  209.           (incf minimum)
  210.           (incf maximum)
  211.           (push-let-binding var `(car ,path) nil)
  212.           (setf path `(cdr ,path)))
  213.          (:optionals
  214.           (incf maximum)
  215.           (push-let-binding var `(car ,path) nil `(not (null ,path)))
  216.           (setf path `(cdr ,path)))
  217.          (:keywords
  218.           (let ((key (make-keyword var)))
  219.             (push-let-binding var `(lookup-keyword ,key ,rest-name)
  220.                       nil)
  221.             (push key keys)))
  222.          (:auxs
  223.           (push-let-binding var nil nil))))
  224.           (t
  225.            (error "Non-symbol in lambda-list - ~S." var)))))
  226.     (push `(unless (<= ,minimum
  227.                (length (the list ,(if top-level
  228.                           `(cdr ,arg-list-name)
  229.                           arg-list-name)))
  230.                ,@(unless restp
  231.                (list maximum)))
  232.          (,error-fun 'defmacro-ll-arg-count-error
  233.              :kind ',error-kind
  234.              ,@(when name `(:name ',name))
  235.              :argument ,(if top-level
  236.                     `(cdr ,arg-list-name)
  237.                     arg-list-name)
  238.              :lambda-list ',lambda-list
  239.              :minimum ,minimum
  240.              ,@(unless restp `(:maximum ,maximum))))
  241.       *arg-tests*)
  242.     (if keys
  243.     (let ((problem (gensym "KEY-PROBLEM-"))
  244.           (info (gensym "INFO-")))
  245.       (push `(multiple-value-bind
  246.              (,problem ,info)
  247.              (verify-keywords ,rest-name ',keys ',allow-other-keys-p)
  248.            (when ,problem
  249.              (,error-fun
  250.               'defmacro-ll-broken-key-list-error
  251.               :kind ',error-kind
  252.               ,@(when name `(:name ',name))
  253.               :problem ,problem
  254.               :info ,info)))
  255.         *arg-tests*)))
  256.     (values env-arg-used minimum (if (null restp) maximum nil))))
  257.  
  258. (defun push-sub-list-binding (variable path object name error-kind error-fun)
  259.   (let ((var (gensym "TEMP-")))
  260.     (push `(,variable
  261.         (let ((,var ,path))
  262.           (if (listp ,var)
  263.           ,var
  264.           (,error-fun 'defmacro-bogus-sublist-error
  265.                   :kind ',error-kind
  266.                   ,@(when name `(:name ',name))
  267.                   :object ,var
  268.                   :lambda-list ',object))))
  269.       *system-lets*)))
  270.  
  271. (defun push-let-binding (variable path systemp &optional condition
  272.                   (init-form *default-default*))
  273.   (let ((let-form (if condition
  274.               `(,variable (if ,condition ,path ,init-form))
  275.               `(,variable ,path))))
  276.     (if systemp
  277.     (push let-form *system-lets*)
  278.     (push let-form *user-lets*))))
  279.  
  280. (defun push-optional-binding (value-var init-form supplied-var condition path
  281.                     name error-kind error-fun)
  282.   (unless supplied-var
  283.     (setf supplied-var (gensym "SUPLIEDP-")))
  284.   (push-let-binding supplied-var condition t)
  285.   (cond ((consp value-var)
  286.      (let ((whole-thing (gensym "OPTIONAL-SUBLIST-")))
  287.        (push-sub-list-binding whole-thing
  288.                   `(if ,supplied-var ,path ,init-form)
  289.                   value-var name error-kind error-fun)
  290.        (parse-defmacro-lambda-list value-var whole-thing name
  291.                        error-kind error-fun)))
  292.     ((symbolp value-var)
  293.      (push-let-binding value-var path nil supplied-var init-form))
  294.     (t
  295.      (error "Illegal optional variable name: ~S" value-var))))
  296.  
  297. (defun make-keyword (symbol)
  298.   "Takes a non-keyword symbol, symbol, and returns the corresponding keyword."
  299.   (intern (symbol-name symbol) *keyword-package*))
  300.  
  301. (defun defmacro-error (problem kind name)
  302.   (error "Illegal or ill-formed ~A argument in ~A~@[ ~S~]."
  303.      problem kind name))
  304.  
  305.  
  306.  
  307. ;;;; Routines used at runtime by the resultant body.
  308.  
  309. ;;; VERIFY-KEYWORDS -- internal
  310. ;;;
  311. ;;; Determine if key-list is a valid list of keyword/value pairs.  Do not
  312. ;;; signal the error directly, 'cause we don't know how it should be signaled.
  313. ;;; 
  314. (defun verify-keywords (key-list valid-keys allow-other-keys)
  315.   (do ((already-processed nil)
  316.        (unknown-keyword nil)
  317.        (remaining key-list (cddr remaining)))
  318.       ((null remaining)
  319.        (if (and unknown-keyword
  320.         (not allow-other-keys)
  321.         (not (lookup-keyword :allow-other-keys key-list)))
  322.        (values :unknown-keyword (list unknown-keyword valid-keys))
  323.        (values nil nil)))
  324.     (cond ((not (and (consp remaining) (listp (cdr remaining))))
  325.        (return (values :dotted-list key-list)))
  326.       ((null (cdr remaining))
  327.        (return (values :odd-length key-list)))
  328.       ((member (car remaining) already-processed)
  329.        (return (values :duplicate (car remaining))))
  330.       ((or (eq (car remaining) :allow-other-keys)
  331.            (member (car remaining) valid-keys))
  332.        (push (car remaining) already-processed))
  333.       (t
  334.        (setf unknown-keyword (car remaining))))))
  335.  
  336. (defun lookup-keyword (keyword key-list)
  337.   (do ((remaining key-list (cddr remaining)))
  338.       ((endp remaining))
  339.     (when (eq keyword (car remaining))
  340.       (return (cadr remaining)))))
  341.  
  342. (defun keyword-supplied-p (keyword key-list)
  343.   (do ((remaining key-list (cddr remaining)))
  344.       ((endp remaining))
  345.     (when (eq keyword (car remaining))
  346.       (return t))))
  347.  
  348.  
  349.  
  350. ;;;; Conditions signaled at runtime by the resultant body.
  351.  
  352. (define-condition defmacro-lambda-list-bind-error (error) (kind name))
  353.  
  354. (defun print-defmacro-ll-bind-error-intro (condition stream)
  355.   (if (null (defmacro-lambda-list-bind-error-name condition))
  356.       (format stream
  357.           "Error while parsing arguments to ~A in ~S:~%"
  358.           (defmacro-lambda-list-bind-error-kind condition)
  359.           (defmacro-lambda-list-bind-error-function-name condition))
  360.       (format stream
  361.           "Error while parsing arguments to ~A ~S:~%"
  362.           (defmacro-lambda-list-bind-error-kind condition)
  363.           (defmacro-lambda-list-bind-error-name condition))))
  364.  
  365. (define-condition defmacro-bogus-sublist-error
  366.           (defmacro-lambda-list-bind-error)
  367.   (object lambda-list)
  368.   (:report
  369.    (lambda (condition stream)
  370.      (print-defmacro-ll-bind-error-intro condition stream)
  371.      (format stream
  372.          "Bogus sublist:~%  ~S~%to satisfy lambda-list:~%  ~:S~%"
  373.          (defmacro-bogus-sublist-error-object condition)
  374.          (defmacro-bogus-sublist-error-lambda-list condition)))))
  375.  
  376. (define-condition defmacro-ll-arg-count-error (defmacro-lambda-list-bind-error)
  377.   (argument lambda-list minimum maximum)
  378.   (:report
  379.    (lambda (condition stream)
  380.      (print-defmacro-ll-bind-error-intro condition stream)
  381.      (format stream
  382.          "Invalid number of elements in:~%  ~:S~%~
  383.          to satisfy lambda-list:~%  ~:S~%"
  384.          (defmacro-ll-arg-count-error-argument condition)
  385.          (defmacro-ll-arg-count-error-lambda-list condition))
  386.      (cond ((null (defmacro-ll-arg-count-error-maximum condition))
  387.         (format stream "Expected at least ~D"
  388.             (defmacro-ll-arg-count-error-minimum condition)))
  389.        ((= (defmacro-ll-arg-count-error-minimum condition)
  390.            (defmacro-ll-arg-count-error-maximum condition))
  391.         (format stream "Expected exactly ~D"
  392.             (defmacro-ll-arg-count-error-minimum condition)))
  393.        (t
  394.         (format stream "Expected between ~D and ~D"
  395.             (defmacro-ll-arg-count-error-minimum condition)
  396.             (defmacro-ll-arg-count-error-maximum condition))))
  397.      (format stream ", but got ~D."
  398.          (length (defmacro-ll-arg-count-error-argument condition))))))
  399.  
  400.  
  401. (define-condition defmacro-ll-broken-key-list-error
  402.           (defmacro-lambda-list-bind-error)
  403.   (problem info)
  404.   (:report (lambda (condition stream)
  405.          (print-defmacro-ll-bind-error-intro condition stream)
  406.          (format stream
  407.              (ecase
  408.              (defmacro-ll-broken-key-list-error-problem condition)
  409.                (:dotted-list
  410.             "Keyword/value list is dotted: ~S")
  411.                (:odd-length
  412.             "Odd number of elements in keyword/value list: ~S")
  413.                (:duplicate
  414.             "Duplicate keyword: ~S")
  415.                (:unknown-keyword
  416.             "~{Unknown keyword: ~S; expected one of ~{~S~^, ~}~}"))
  417.              (defmacro-ll-broken-key-list-error-info condition)))))
  418.